home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gnu / adainc / i-cpp.adb < prev    next >
Text File  |  1996-01-30  |  7KB  |  205 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                       I N T E R F A C E S . C P P                        --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.3 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Interfaces.C;
  27.  
  28. package body Interfaces.CPP is
  29.  
  30.    use System.Storage_Elements;
  31.    use type Interfaces.C.Short;
  32.  
  33.    type Vtable_Entry is record
  34.      Delta1 : C.Short := 0;
  35.      Index  : C.Short := 0;
  36.      Pfn    : System.Address := System.Null_Address;
  37.    end record;
  38.    --  The entry in the vtable. This is the most compiler dependant part.
  39.  
  40.    type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry;
  41.  
  42.    subtype Big_Vtable_Entry_Array is Vtable_Entry_Array (Positive);
  43.    --  Dummy type only used to declare Vtable_Ptr which must be a pointer
  44.    --  to a constrained array
  45.  
  46.    type Vtable is record
  47.       Idepth    : C.Short;
  48.       Unused    : C.Short;
  49.       Ancestors : System.Address;
  50.       --  The first entry in the G++ VTable is unused, we take advantage of
  51.       --  that for inserting our type specific information
  52.  
  53.       Table     : Big_Vtable_Entry_Array;
  54.    end record;
  55.  
  56.    type Address_Array is array (C.Short range <>) of System.Address;
  57.    subtype Big_Address_Array is Address_Array (C.Short);
  58.    type Address_Array_Ptr is access all Big_Address_Array;
  59.  
  60.    function To_Address_Array_Ptr is
  61.      new Unchecked_Conversion (System.Address, Address_Array_Ptr);
  62.  
  63.    function To_Address is
  64.      new Unchecked_Conversion (Vtable_Ptr, System.Address);
  65.  
  66.    ---------------------------
  67.    -- Set_Vfunction_Address --
  68.    ---------------------------
  69.  
  70.    procedure Set_Vfunction_Address
  71.      (Vptr     : Vtable_Ptr;
  72.       Position : Positive;
  73.       Value    : System.Address)
  74.    is
  75.    begin
  76.       Vptr.Table (Position).Pfn := Value;
  77.    end Set_Vfunction_Address;
  78.  
  79.    ---------------------------
  80.    -- Get_Vfunction_Address --
  81.    ---------------------------
  82.  
  83.    function Get_Vfunction_Address
  84.      (Vptr     : Vtable_Ptr;
  85.       Position : Positive)
  86.       return     System.Address
  87.    is
  88.    begin
  89.       return Vptr.Table (Position).Pfn;
  90.    end Get_Vfunction_Address;
  91.  
  92.    ----------------
  93.    -- Set_Idepth --
  94.    ----------------
  95.  
  96.    procedure Set_Idepth (Vptr  : Vtable_Ptr; Value : Natural) is
  97.    begin
  98.       Vptr.Idepth := C.Short (Value);
  99.    end Set_Idepth;
  100.  
  101.    ----------------
  102.    -- Get_Idepth --
  103.    ----------------
  104.  
  105.    function Get_Idepth (Vptr : Vtable_Ptr) return Natural is
  106.    begin
  107.       return Natural (Vptr.Idepth);
  108.    end Get_Idepth;
  109.  
  110.    ------------------------
  111.    -- Set_Ancestor_Vptrs --
  112.    ------------------------
  113.  
  114.    procedure Set_Ancestor_Vptrs (Vptr : Vtable_Ptr; Value : System.Address) is
  115.    begin
  116.       Vptr.Ancestors := Value;
  117.    end Set_Ancestor_Vptrs;
  118.  
  119.    ------------------------
  120.    -- Get_Ancestor_Vptrs --
  121.    ------------------------
  122.  
  123.    function  Get_Ancestor_Vptrs (Vptr : Vtable_Ptr) return System.Address is
  124.    begin
  125.       return Vptr.Ancestors;
  126.    end Get_Ancestor_Vptrs;
  127.  
  128.    --------------------
  129.    -- Displaced_This --
  130.    --------------------
  131.  
  132.    function Displaced_This
  133.     (Current_This : System.Address;
  134.      Vptr         : Vtable_Ptr;
  135.      Position     : Positive)
  136.      return         System.Address
  137.    is
  138.    begin
  139.       return Current_This + Storage_Offset (Vptr.Table (Position).Delta1);
  140.    end Displaced_This;
  141.  
  142.    -----------------
  143.    -- Vtable_Size --
  144.    -----------------
  145.  
  146.    function Vtable_Size (Entry_Count : Natural) return Storage_Count is
  147.  
  148.       type VT is record
  149.          Idepth    : C.Short;
  150.          Unused    : C.Short;
  151.          Ancestors : System.Address;
  152.          Table     : Vtable_Entry_Array (1 .. Entry_Count);
  153.       end record;
  154.       --  Dummy declaration, just to get the size
  155.  
  156.    begin
  157.       return (VT'Size + System.Storage_Unit - 1) / System.Storage_Unit;
  158.    end Vtable_Size;
  159.  
  160.    --------------------
  161.    -- Inherit_Vtable --
  162.    --------------------
  163.  
  164.    procedure Inherit_Vtable
  165.     (Old_Vptr    : Vtable_Ptr;
  166.      New_Vptr    : Vtable_Ptr;
  167.      Entry_Count : Natural)
  168.    is
  169.    begin
  170.       --  Inherit Virtual functions
  171.  
  172.       New_Vptr.Table (1 .. Entry_Count) := Old_Vptr.Table (1 .. Entry_Count);
  173.  
  174.       --  The inheritance depth is incremented
  175.  
  176.       New_Vptr.Idepth := Old_Vptr.Idepth + 1;
  177.  
  178.       --  The Ancestor Vtable ptr Table is also inherited (with a shift)
  179.  
  180.       To_Address_Array_Ptr (New_Vptr.Ancestors) (1 .. New_Vptr.Idepth)
  181.         := To_Address_Array_Ptr (Old_Vptr.Ancestors) (0 .. Old_Vptr.Idepth);
  182.  
  183.       To_Address_Array_Ptr (New_Vptr.Ancestors) (0) := To_Address (New_Vptr);
  184.    end Inherit_Vtable;
  185.  
  186.  
  187.    --------------------
  188.    -- CPP_Membership --
  189.    --------------------
  190.  
  191.    function CPP_Membership
  192.      (Obj_Vptr : Vtable_Ptr;
  193.       Typ_Vptr : Vtable_Ptr)
  194.       return     Boolean
  195.    is
  196.       Pos : constant C.Short := Obj_Vptr.Idepth - Typ_Vptr.Idepth;
  197.  
  198.    begin
  199.       return Pos >= 0
  200.         and then To_Address_Array_Ptr (Obj_Vptr.Ancestors) (Pos) =
  201.                  To_Address (Typ_Vptr);
  202.    end CPP_Membership;
  203.  
  204. end Interfaces.CPP;
  205.